perm filename SLOOP2.F4[P11,LCS] blob
sn#592326 filedate 1981-06-09 generic text, type T, neo UTF8
C**** SLOOP, SLRS, RNOTE, DRWNT, RDRAW, CIRCLE, RUNTHR
SUBROUTINE SLOOP
COMMON/SLR/ SLURX(32)
COMMON /XRN/RN(1) /PLTR/IPLT,RHT,RDIS
COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
1 J5,J6,J7,J8,J9,J10,J11,JQ(7),R,RJ
COMMON/PTR/KWDS(1) /STF/RSTFAC(8),RSTJ2
1 /LIMIT/LIMIT,ITEM,L,I,IX /ALF/INP,SLURY(72)
IXC=0
RSEG=L
SY=L-1
IHLF=L/2
RHLF=IHLF
C L = NUMB OF SEGMENTS IN CURVE.
RDR=1.0
RB=RX/SY
ARX=0
CC KK=0
CC81 KK=KK+1
CCCC RA=ARX
CC SLURX(KK)=ARX*RB+R3
CC ARX=ARX+1.
CC IF(KK.LT.L)GO TO 81
DO 81 K=1,L
SLURX(K)=ARX+R3
81 ARX=ARX+RB
C BOTTOM OF FIRST LOOP. FILL IN X COORD.
RA=-R7*RST7
LRB=0
IF(R9.EQ.0)R9=2.8
R=CENTR-RA
RK=RHLF
IF(RJ.GT.0)RK=RSEG
RNT=RK
CC RA=-RA
IF(RJ.GE.200.)IXC=-1
C RJ HAS ABS(R7) >=200 IS RT. 1/2 OF SLUR ONLY.
IF(R10.LE.0.OR.R10.GE.1.0)GO TO 40
A2=R10
IF(R10.GE.0.5)GO TO 440
C R10<>0 SHIFTS CENTER OF CURVATURE.
IXC=-1
A2=1.0-R10
440 RNT=RSEG*A2
CC A0=RSEG-RNT
CC RDR=RNT/A0
RDR=RNT/(RSEG-RNT)
RK=RNT
40 LRB=LRB+1
A2=RK/RNT
IF(A2.GE.0.1)GO TO 140
SLURY(LRB)=R
GO TO 240
140 RW=RA*A2**R9+R
CC140 RW=RA*A2**ARX+R
SLURY(LRB)=RW
240 IF(RK.LE.1.0)GO TO 340
RK=RK-1.0
GO TO 40
340 IF(RNT.NE.RSEG)GO TO 4
5 IF(RJ.EQ.0)GO TO 15
IF(IXC.GE.0)GO TO 3
15 KK=1
LRB=L
SY=SLURY(IHLF)
CC IF(JA.EQ.5)GO TO 6
C WHEN IS NEXT USED?
CC A2=2.*SLURY(IHLF)
CC A2=A2/RHLF
CC A1=A2
6 RZ=SLURY(LRB)
CCC CALL EXCH(RZ,SLURY(KK))
RZ=SLURY(KK)
SLURY(KK)=SLURY(LRB)
IF(RJ.EQ.0)RZ=RZ-2.*(RZ-SY)
CC IF(RJ.NE.0)GO TO 7
CC A0=RZ
CC RZ=2.*(RZ-SY)
C SY=NUM. OF SEGS. IN SLUR
CC RZ=A0-RZ
CC IF(JA.EQ.5)GO TO 7
CC A0=A2*A1
CC RZ=RZ-A0
CC A1=A1-1.0
7 SLURY(LRB)=RZ
IF(KK.EQ.IHLF)GO TO 1
LRB=LRB-1
KK=KK+1
GO TO 6
4 LRZ=L
CC RB=RDR
RK=1.0
2 KS=RK
SLURY(LRZ)=SLURY(KS)
CC RK=RK+RB
RK=RK+RDR
IF(RK.GT.RNT)GO TO 5
LRZ=LRZ-1
GO TO 2
CC1 IF(JA.EQ.5)RJ=SLURY(IHLF)
1 RJ=SLURY(IHLF)
3 IF(RTILT.EQ.0)RETURN
RW=ATAN2(RTILT,RXX)
RA=SIN(RW)
RB=COS(RW)
RZ=SLURX(1)
RW=SLURY(1)
DO 83 K=1,L
R=SLURX(K)-RZ
ARX=SLURY(K)-RW
SLURX(K)=RB*R-RA*ARX+RZ
83 SLURY(K)=RB*ARX+RA*R+RW
END
SUBROUTINE SLRS
COMMON R2,JA,CTR,J2,RJQ(20),J3,J4,J5,J6,J7,J8,J9,J10,J11
COMMON /ALF/INP,SLURY(72) /SLR/SLURX(32)
K12=J6
K15=2
IF(J11.EQ.0)GO TO 22
K14=0
K13=1
122 K14=K14+1
IF(K14.LT.J11)GO TO 22
K14=0
K15=K15+K13
K13=-K13
22 CALL LINES(SLURX(K12),SLURY(K12),K15)
C J11 SETS DASH SIZE. (CURRENTLY =3 SEGMENTS)
K12=K12+J5
IF(J5.LT.0)GO TO 322
IF(K12.GT.J7)RETURN
222 IF(J11.EQ.0)GO TO 22
GO TO 122
322 IF(K12.GE.J7)GO TO 222
END
SUBROUTINE RNOTE(X)
COMMON /PTR/KWDS(1)/XRN/RN(1)
K=X
X=RN(KWDS(MOD(K,1000)))
END
SUBROUTINE DRWNT
C [RMINI IS ALF+=49]
COMMON /STF/RSTFAC(0/7),RSTJ2 /ALF/INP(49),RMINI
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
EQUIVALENCE (J5,JQ(3)),(R6,RJQ(4)),(R5,RJQ(3))
1,(J7,JQ(5)),(R7,RJQ(5)),(RJZ,RJQ(20)),(R4,RJQ(2))
1 ,(J9,JQ(7)),(R9,RJQ(7)),(J8,JQ(6)),(R8,RJQ(6))
RJX=CENTR
JB=J5
J8=0
C J8=0 SO IT WILL FILL. (P8 IN 'CLEFS')
RA=R6
R6=.5*RMINI/RSTJ2
R7=R6
R4=RJZ-3.
J9=0
RDR=R8
R8=0
CALL CLEFS
R8=RDR
J9=R9
C ↑↑↑↑↑↑ NEEDED??
C FOR WHITE NOTES AND ACCIS ON PLOTTER.
CENTR=RJX
R6=RA
R7=J7
J5=R5
END
C (ALIGNMENT ABOVE IS OFF!)
SUBROUTINE RDRAW(I,S,XY,X,R3,CENTR,RMINI)
DIMENSION XY(1)
DO 2 K=I,IFIX(S)
L=2
Y=XY(K)
IF(Y.LT.1000.)GO TO 3
L=3
Y=Y-1000.
C >1000 = INVIS. LINE
3 M=Y
Y=(Y-M)*1000.
IF(Y.GT.100.)Y=100-Y
C Y NUMBERS .GT.100 ARE NEG.
B=Y*X+CENTR
IF(M.GT.60)M=100-M
A=M*RMINI+R3
2 CALL LINES(A,B,L)
END
C JA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
SUBROUTINE CIRCLE
COMMON /PLTR/IPLT,RHT,RDIS /STF/RSTFAC(8),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(11),L,KQ,K,R,RA,RB
EQUIVALENCE (J6,JQ(4)),(R5,RJQ(3)),(J7,JQ(5)),(J8,JQ(6))
1 ,(R3,RJQ(1))
RA=5.96*RSTJ2*R5
RB=J8*RDIS
IF(J7.LE.J6)J7=J7+360
KQ=6
C ON DPY DRAW ONLY EVERY 6TH POINT. (DO ALL WHEN IPLT=-1)
IF(IPLT.LT.0)KQ=1
10 L=3
DO 3 K=J6,J7,KQ
R=K
CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
3 L=2
RB=RB-1.
IF(RB.LT.0)RETURN
RA=RA+1./RDIS
GO TO 10
END
C****CALLED FROM MAIN. -- FOR EDITING *******
SUBROUTINE RUNTHR(M)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),N,K,A /XRN/RN(1)
N=RN(M)
JA=RN(M+1)
M=M+2
R2=RN(M)
CC JUMPGE 6,NONEG ;IF(R2.GE.0)GO TO NONEG
CC MOVE 6,[4.0] ;CHANGE OLD NEG. STF NUM TO STF4*********
CC MOVEM 6,(2) ;PUT IT BACK INTO ARRAY
DO 1 K=1,10
C*** ONLY 12 PARAMETERS USED AT THIS TIME******
IF(K.GT.N)GO TO 2
A=RN(M+K)
RJQ(K)=A
JQ(K)=A
GO TO 1
2 RJQ(K)=0
JQ(K)=0
1 CONTINUE
M=N+M+1
C SET POINTER AHEAD FOR NEXT ITEM IN RN ARRAY.
END